home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr46
/
tpfort18.zip
/
PSAMPLE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-03-08
|
2KB
|
82 lines
{ This is a sample Pascal program that loads and calls some Fortran routines }
{$N+} { Use 80x87 }
{$E+} { Link emulator }
{$D+} { Debug info }
{$L+} { Local symbols }
{$M 2048,0,655360} { There's no need for a large stack, since this program
spends most of its time in "Fortran Mode". }
program PSample;
uses
FortLink, { the fortran linking unit }
FSample; { the unit with the dummy declarations }
{$f+,s-} { SumCube is a far routine with no stack checking, because it'll
be called by a Fortran routine }
function SumCube(var N:longint; var X:realarray; { Mimic the Fortran parameters
first }
Value_ofs:word):double_ptr; { Always add another parameter for the
return address, and return a pointer }
{ This looks to Fortran like
REAL*8 FUNCTION SUMCUBE(N,X)
INTEGER N
REAL*8 X(N)
}
var
value : double_ptr;
i : integer;
begin
Enter_Pascal;
value := ptr(sseg,Value_ofs); { Always address it on the stack segment! }
{ calculate the value and store it in value^ }
writeln('In sumcube, called from Fortran, and calling a Fortran routine');
value^ := 0.0;
for i := 1 to N do
value^ := value^ + Cube(X[i]); { Note that Cube is a Fortran routine }
{ set the function value to the pointer, and return }
sumcube := value;
Leave_Pascal;
end;
{$s+,f-} { Put the options back to normal }
{$F+} { MUST be a far call }
procedure Main; { the main routine of the TP program, which can
safely call Fortran }
var
n : longint;
x : ^realarray; { Realarray is defined as a big array of doubles }
sumcube_address : extval;
i : integer;
value : double;
begin
n := 10;
getmem(x,n*sizeof(double));
for i:=1 to n do
x^[i] := i;
writeln('Passing TP routine to a Fortran subroutine...');
{ This pushes @sumcube onto the stack }
sumcube_address := Pas_External(@sumcube);
Eval(sumcube_address,n,x^,value);
writeln('The sum of cubes of 1 to ',n,' is ',value:10:1);
Clean_External; { This call cleans @sumcube off the stack. }
freemem(x,n*sizeof(double));
end;
{$F-}
begin
if not LoadFort('fsample.ldr',@main) then
writeln('Load failed!');
UnloadFort;
end.